diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 76588cb08..1a9cb0ef4 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -326,7 +326,10 @@ derivePersistFieldJSON ''ExamGradingRule newtype ExamPassed = ExamPassed { examPassed :: Bool } deriving (Read, Show, Generic, Typeable) - deriving newtype (Eq, Ord, Enum, Bounded, PersistField, PersistFieldSql) + deriving newtype (Eq, Ord, Enum, Bounded, PersistField) + +instance PersistFieldSql ExamPassed where + sqlType _ = sqlType $ Proxy @Bool deriveFinite ''ExamPassed finitePathPiece ''ExamPassed ["failed", "passed"] diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index 5beb0ef55..be8922eff 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -19,7 +19,7 @@ module Model.Types.File import Import.NoModel -import Database.Persist.Sql (PersistFieldSql) +import Database.Persist.Sql (PersistFieldSql(..)) import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Data.ByteArray (ByteArrayAccess) @@ -42,24 +42,30 @@ import qualified Data.Map as Map newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) - deriving newtype ( PersistField, PersistFieldSql + deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON , Hashable, NFData , ByteArrayAccess , Binary ) +instance PersistFieldSql FileContentChunkReference where + sqlType _ = sqlType $ Proxy @(Digest SHA3_512) + makeWrapped ''FileContentChunkReference newtype FileContentReference = FileContentReference (Digest SHA3_512) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) - deriving newtype ( PersistField, PersistFieldSql + deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON , Hashable, NFData , ByteArrayAccess , Binary ) +instance PersistFieldSql FileContentReference where + sqlType _ = sqlType $ Proxy @(Digest SHA3_512) + makeWrapped ''FileContentReference diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index be993e10b..a6e96ad4f 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -19,7 +19,7 @@ import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import Crypto.Hash (digestFromByteString, SHAKE128) -import Database.Persist.Sql (PersistFieldSql) +import Database.Persist.Sql (PersistFieldSql(..)) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA @@ -102,11 +102,14 @@ derivePersistFieldJSON ''NotificationSettings newtype BounceSecret = BounceSecret (Digest (SHAKE128 64)) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) - deriving newtype ( PersistField, PersistFieldSql + deriving newtype ( PersistField , Hashable, NFData , ByteArrayAccess ) +instance PersistFieldSql BounceSecret where + sqlType _ = sqlType $ Proxy @(Digest (SHAKE128 64)) + instance PathPiece BounceSecret where toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8 @@ -120,10 +123,13 @@ derivePersistFieldJSON ''MailContent newtype MailContentReference = MailContentReference (Digest SHA3_512) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) - deriving newtype ( PersistField, PersistFieldSql + deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON , Hashable, NFData , ByteArrayAccess ) +instance PersistFieldSql MailContentReference where + sqlType _ = sqlType $ Proxy @(Digest SHA3_512) + derivePersistFieldJSON ''MailHeaders diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 8abaec90a..4d52b6939 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -54,9 +54,12 @@ type PseudonymWord = CI Text newtype Pseudonym = Pseudonym Word24 deriving (Eq, Ord, Read, Show, Generic, Data) deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix - , PersistField, PersistFieldSql, Random + , PersistField, Random ) +instance PersistFieldSql Pseudonym where + sqlType _ = sqlType $ Proxy @Word24 + instance FromJSON Pseudonym where parseJSON v@(Aeson.Number _) = do w <- parseJSON v :: Aeson.Parser Word32 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index cdea870ed..97cee5966 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -81,18 +81,24 @@ deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (W newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) - deriving newtype ( PersistField, PersistFieldSql + deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON , Hashable, NFData , ByteArrayAccess , Binary ) +instance PersistFieldSql WorkflowGraphReference where + sqlType _ = sqlType $ Proxy @(Digest SHA3_256) + ----- WORKFLOW GRAPH: NODES ----- newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + +instance PersistFieldSql WorkflowGraphNodeLabel where + sqlType _ = sqlType $ Proxy @(CI Text) data WorkflowGraphNode fileid userid = WGN { wgnFinal :: Maybe Icon @@ -123,7 +129,10 @@ data WorkflowNodeMessage userid = WorkflowNodeMessage newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + +instance PersistFieldSql WorkflowGraphEdgeLabel where + sqlType _ = sqlType $ Proxy @(CI Text) data WorkflowGraphRestriction = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel } @@ -352,7 +361,10 @@ classifyWorkflowScope = \case newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) - deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + +instance PersistFieldSql WorkflowPayloadLabel where + sqlType _ = sqlType $ Proxy @(CI Text) newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index d41b7fb76..de3f76087 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -16,8 +16,9 @@ module Utils.DateTime , day ) where -import ClassyPrelude.Yesod hiding (lift) +import ClassyPrelude.Yesod hiding (lift, Proxy(..)) import System.Locale.Read +import Data.Proxy import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..), DiffTime) import Data.Time.Zones as Zones (TZ) @@ -38,7 +39,7 @@ import Instances.TH.Lift () import Data.Data (Data) import Data.Universe -import Database.Persist.Sql (PersistFieldSql) +import Database.Persist.Sql (PersistFieldSql(..)) import Utils.PathPiece @@ -98,7 +99,10 @@ instance HasLocalTime TimeOfDay where newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) - deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString) + deriving newtype (ToJSON, FromJSON, PersistField, IsString) + +instance PersistFieldSql DateTimeFormat where + sqlType _ = sqlType $ Proxy @String instance Hashable DateTimeFormat